home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / pois2.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  26.0 KB  |  800 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module pois2)
  13.  
  14. (DECLARE-top (SPECIAL *ARGC *COEF POISVALS POISCO1 POISCOM1 B* A* *A SS
  15.           CC H* POISHIFT POISTSM POISSIZ POISTS $WTLVL $POISZ $POIS1)
  16.      (*LEXPR $PRINT $COEFF)
  17.      (GENPREFIX \P)) 
  18.  
  19. (DEFVAR TRIM NIL)
  20.  
  21. ;;(DEFUN CHECKENCODE (R) ; any relation to checkenman?
  22. ;;       (PROG (Q)
  23. ;;         (MAPC
  24. ;;          #'(LAMBDA (U)
  25. ;;            (SETQ Q ($COEFF R U))
  26. ;;            (COND ((AND (INTEGERP Q)
  27. ;;                    (LESSP (ABS Q) POISTSM))
  28. ;;                   (SETQ R (ADD R (MUL -1 U Q))))
  29. ;;                  (T (RETURN NIL))))
  30. ;;          '($U $V $W $X $Y $Z))
  31. ;;         (RETURN (EQUAL R 0))))
  32.  
  33. ;(DEFMFUN $POISSIMP (X)
  34. ; (IF (MBAGP X) (CONS (CAR X) (MAPCAR #'$POISSIMP (CDR X))) ($OUTOFPOIS X))) 
  35.  
  36. ;(DEFPROP MPOIS (LAMBDA (X) X) MFEXPR*) 
  37. (defmspec mpois (x) x)
  38.  
  39.  
  40. ;(DEFMFUN $POISPLUS (A B)
  41. ;   (SETQ A (INTOPOIS A) B (INTOPOIS B))
  42. ;   (LIST '(MPOIS SIMP)
  43. ;     (POISMERGE22 (CADR A) (CADR B))
  44. ;     (POISMERGE22 (CADDR A) (CADDR B))))
  45.  
  46. (declare-top (SPECIAL *B *FN)) 
  47. ;(DEFMFUN $POISMAP (P SINFN COSFN)
  48. ;   (PROG (*B *FN)
  49. ;    (SETQ P (INTOPOIS P))
  50. ;    (SETQ *FN (LIST SINFN))
  51. ;    (RETURN (LIST (CAR P) (POISMAP (CADR P))
  52. ;              (PROG2 (SETQ *FN (LIST COSFN))
  53. ;                 (POISMAP (CADDR P))))))) 
  54.  
  55. ;(DEFUN POISMAP (Y)
  56. ;   (COND ((NULL Y) NIL)
  57. ;     (T (SETQ *B (MEVAL (LIST *FN
  58. ;                  (POISCDECODE (CADR Y))
  59. ;                  (POISDECODEC (CAR Y)))))
  60. ;        (TCONS3 (CAR Y) (INTOPOISCO *B) (POISMAP (CDDR Y))))))
  61.  
  62. ;(DEFUN POISMERGE22 (R S)
  63. ;   (COND ((NULL R) S)
  64. ;     ((NULL S) R)
  65. ;     ((EQUAL (CAR R) (CAR S))
  66. ;      (PROG (TT)
  67. ;         (SETQ TT (POISCO+ (CADR R) (CADR S)))
  68. ;         (RETURN (COND ((POISPZERO TT) (POISMERGE22 (CDDR R) (CDDR S)))
  69. ;               (T (CONS (CAR S)
  70. ;                    (CONS TT (POISMERGE22 (CDDR R) (CDDR S)))))))))
  71. ;     ((LESSP (CAR R) (CAR S))
  72. ;      (CONS (CAR R) (CONS (CADR R) (POISMERGE22 (CDDR R) S))))
  73. ;     (T (CONS (CAR S) (CONS (CADR S) (POISMERGE22 (CDDR S) R)))))) 
  74.  
  75. ;(DEFUN POISCOSINE (M)
  76. ;   (SETQ M (POISENCODE M))
  77. ;   (COND ((POISNEGPRED M) (SETQ M (POISCHANGESIGN M))))
  78. ;   (LIST '(MPOIS SIMP) NIL (LIST M POISCO1))) 
  79.  
  80. ;(DEFUN POISSINE (M)
  81. ;   (SETQ M (POISENCODE M))
  82. ;   (COND ((POISNEGPRED M) (LIST '(MPOIS SIMP)
  83. ;                (LIST (POISCHANGESIGN M) POISCOM1)
  84. ;                NIL))
  85. ;     (T (LIST '(MPOIS SIMP)
  86. ;          (LIST M POISCO1)
  87. ;          NIL))))
  88.  
  89. ;(DEFMFUN $INTOPOIS (X)
  90. ;    (PROG (*A) (RETURN (INTOPOIS X)))) 
  91.  
  92. ;(DEFUN INTOPOIS (A)
  93. ;   (COND ((ATOM A) (COND ((EQUAL A 0) $POISZ)
  94. ;             (T (LIST '(MPOIS SIMP) NIL (LIST POISHIFT (INTOPOISCO A))))))
  95. ;     ((EQ (CAAR A) 'MPOIS) A)
  96. ;     ((EQ (CAAR A) '%SIN) (POISSINE (CADR A)))
  97. ;     ((EQ (CAAR A) '%COS) (POISCOSINE (CADR A)))
  98. ;     ((AND (EQ (CAAR A) 'MEXPT)
  99. ;           (NUMBERP (CADDR A))
  100. ;           (GREATERP (CADDR A) 0))
  101. ;      ($POISEXPT (INTOPOIS (CADR A)) (CADDR A)))
  102. ;     ((EQ (CAAR A) 'MPLUS)
  103. ;      (SETQ *A (INTOPOIS (CADR A)))
  104. ;      (MAPC (FUNCTION
  105. ;         (LAMBDA (Z) (SETQ *A ($POISPLUS *A (INTOPOIS Z)))))
  106. ;        (CDDR A))
  107. ;       *A)
  108. ;     ((EQ (CAAR A) 'MTIMES)
  109. ;      (SETQ *A (INTOPOIS (CADR A)))
  110. ;      (MAPC (FUNCTION
  111. ;         (LAMBDA (Z) (SETQ *A ($POISTIMES *A (INTOPOIS Z)))))
  112. ;        (CDDR A))
  113. ;        *A)
  114. ;     ((EQ (CAAR A) 'MRAT)
  115. ;      (INTOPOIS (RATDISREP A)))
  116. ;     (T (LIST '(MPOIS SIMP) NIL (LIST POISHIFT (INTOPOISCO A)))))) 
  117.  
  118. ;(DEFUN TCONS (R S)
  119. ;       (COND ((POISPZERO (CAR S)) (CDR S))
  120. ;         (T (CONS R S)))) 
  121.  
  122. ;(DEFUN POISNEGPRED ($N)
  123. ;   (PROG  ($R)
  124. ;    $LOOP (COND ((EQUAL $N 0) (RETURN NIL))
  125. ;        (T NIL))
  126. ;          (SETQ $R (DIFFERENCE (REMAINDER $N POISTS) POISTSM))
  127. ;      (COND ((GREATERP $R 0) (RETURN NIL))
  128. ;        ((GREATERP 0 $R) (RETURN T))
  129. ;        (T (SETQ $N (QUOTIENT $N POISTS))))
  130. ;      (GO $LOOP))) 
  131.  
  132. ;(DEFUN POISCHANGESIGN ($N)
  133. ;       (DIFFERENCE (TIMES POISHIFT 2) $N))
  134.  
  135. ;(DEFUN POISENCODE (H*)
  136. ;   (COND ((NOT (CHECKENCODE H*))
  137. ;      (merror "Illegal arg to POISSIMP:~%~M" H*)))
  138. ;   (APPLY (FUNCTION (LAMBDA ($Z $Y $X $W $V $U)
  139. ;              (DECLARE (SPECIAL $U $V $W $X $Y $Z)) 
  140. ;            (SETQ H* (MEVAL H*))
  141. ;            (COND ((NOT (INTEGERP H*))
  142. ;                   (merror  "Illegal trig arg to POISSON form")))
  143. ;            (PLUS POISHIFT H*)))
  144. ;      POISVALS))
  145.  
  146. (DEFUN POISLIM1 (U N)
  147.    U ;Ignored
  148.    (COND ((NOT (fixnump N))
  149.       (merror "Improper argument to POISLIM:~%~M" N)))
  150.    (SETQ POISVALS NIL)
  151.    (SETQ POISTS #+NIL (ash 1 n) #-NIL (EXPT 2 N))
  152.    (DO ((J 0 (f1+ J))) ((> J 5))
  153.      (SETQ POISVALS (CONS (EXPT POISTS J) POISVALS)))
  154.    (SETQ POISSIZ N
  155.      POISTSM (EXPT 2 (SUB1 N))
  156.      POISHIFT (PROG (SUM)
  157.              (SETQ SUM 0)
  158.              (DO ((I 0 (f1+ I))) ((> I 5))
  159.                (SETQ SUM (PLUS SUM (TIMES POISTSM (EXPT POISTS I)))))
  160.              (RETURN SUM))
  161.      $POISZ '((MPOIS SIMP) NIL NIL)
  162.      $POIS1 (LIST '(MPOIS SIMP) NIL (LIST POISHIFT 1)))
  163.    N)
  164.  
  165. ;(DEFUN POISDECODEC (M &AUX ARG H)
  166. ;   (SETQ ARG 0)
  167. ;   (SETQ H M)
  168. ;   (MAPC
  169. ;    #'(LAMBDA (V)
  170. ;         (SETQ ARG (ADD ARG (MUL (DIFFERENCE (REMAINDER H POISTS) POISTSM)
  171. ;                 V)))
  172. ;     (SETQ H (QUOTIENT H POISTS)))
  173. ;    '($U $V $W $X $Y $Z))
  174. ;   ARG) 
  175.  
  176. ;(DEFMFUN $POISCTIMES (C P)
  177. ;   (LIST '(MPOIS SIMP)
  178. ;     (POISCTIMES1 (SETQ C (INTOPOISCO C))
  179. ;              (CADR P))
  180. ;     (POISCTIMES1 C (CADDR P))))
  181.  
  182. ;(DEFMFUN $OUTOFPOIS (P)
  183. ;   (PROG (ANS)
  184. ;    (COND ((OR (ATOM P) (NOT (EQ (CAAR P) 'MPOIS)))
  185. ;           (SETQ P (INTOPOIS P))))
  186. ;    (DO M (CADR P) (CDDR M) (NULL M)
  187. ;      (SETQ ANS (CONS (LIST '(MTIMES) (POISCDECODE (CADR M))
  188. ;                 (LIST '(%SIN) (POISDECODEC (CAR M))))
  189. ;              ANS)))
  190. ;    (DO M (CADDR P) (CDDR M) (NULL M)
  191. ;      (SETQ ANS (CONS (LIST '(MTIMES) (POISCDECODE (CADR M))
  192. ;                (COND ((EQUAL (CAR M) POISHIFT) 1)
  193. ;                      (T (LIST '(%COS) (POISDECODEC (CAR M))))))
  194. ;              ANS)))
  195. ;    (RETURN (COND ((NULL ANS) 0)
  196. ;              (T (SIMPLIFYA (CONS '(MPLUS) ANS) NIL)))))) 
  197.  
  198. ;(DEFMFUN $PRINTPOIS (P)
  199. ;   (PROG ()
  200. ;      (SETQ P (INTOPOIS P))
  201. ;      (DO M (CADR P) (CDDR M) (NULL M)
  202. ;     (DISPLA (SIMPLIFYA (LIST '(MTIMES) (POISCDECODE (CADR M))
  203. ;                   (LIST '(%SIN) (POISDECODEC (CAR M))))
  204. ;                 T))
  205. ;     (TERPRI))
  206. ;      (DO M (CADDR P) (CDDR M) (NULL M)
  207. ;     (DISPLA (SIMPLIFYA (LIST '(MTIMES) (POISCDECODE (CADR M))
  208. ;                  (COND ((EQUAL (CAR M) POISHIFT) 1)
  209. ;                    (T (LIST '(%COS) (POISDECODEC (CAR M))))))
  210. ;                T))
  211. ;     (TERPRI))
  212. ;      (RETURN '$DONE)))
  213.  
  214. ;(DEFMFUN $POISDIFF (P M)
  215. ;  (DECLARE (SPECIAL M)) 
  216. ;   (COND ((MEMQ M '($U $V $W $X $Y $Z))
  217. ;      (LIST (CAR P)
  218. ;        (COSDIF (CADDR P) M)
  219. ;        (SINDIF (CADR P) M)))
  220. ;     (T (LIST (CAR P)
  221. ;          (POISDIF4 (CADR P))
  222. ;          (POISDIF4 (CADDR P))))))
  223.  
  224. ;(DEFUN POISDIF4 (Y)
  225. ;  (declare (special m))
  226. ;   (COND ((NULL Y) NIL)
  227. ;     (T (TCONS3 (CAR Y)
  228. ;            (POISCODIF (CADR Y) M)
  229. ;            (POISDIF4 (CDDR Y)))))) 
  230.  
  231. ;(DEFUN COSDIF (H M)
  232. ;   (COND ((NULL H) NIL)
  233. ;     (T (TCONS (CAR H)
  234. ;           (CONS (POISCO* (INTOPOISCO (MINUS (POISXCOEF (CAR H) M))) (CADR H))
  235. ;             (COSDIF (CDDR H) M))))))
  236.  
  237. ;(DEFUN SINDIF (H M)
  238. ;   (COND ((NULL H) NIL)
  239. ;     (T (TCONS (CAR H)
  240. ;           (CONS (POISCO* (INTOPOISCO (POISXCOEF (CAR H) M)) (CADR H))
  241. ;             (SINDIF (CDDR H) M)))))) 
  242.  
  243. ;(DEFUN POISXCOEF (H M)
  244. ;   (DIFFERENCE
  245. ;      (REMAINDER (QUOTIENT H (EXPT POISTS
  246. ;                   (CADR (MEMQ M '($U 0 $V 1 $W 2 $X 3 $Y 4 $Z 5)))))
  247. ;         POISTS)
  248. ;      POISTSM))
  249.  
  250. (DEFUN NONPERIOD (P)
  251.    (AND (NULL (CADR P))
  252.     (EQUAL (CAADDR P) POISHIFT)
  253.     (NULL (CDDR (CADDR P))))) 
  254.  
  255. (DECLARE-top (SPECIAL ANS)) 
  256.  
  257. ;(MACRO KEY  (L) (CONS 'CAR (CDR L))) 
  258.  
  259. ;(MACRO LLINK  (L) (CONS 'CAADR (CDR L))) 
  260.  
  261. ;(MACRO RLINK  (L) (CONS 'CDADR (CDR L))) 
  262.  
  263. ;(MACRO BP  (L) (CONS 'CADDR (CDR L))) 
  264.  
  265. ;(MACRO REC  (L) (CONS 'CDDDR (CDR L))) 
  266.  
  267. ;(MACRO ORDER<  (L) (CONS 'LESSP (CDR L))) 
  268.  
  269. ;(MACRO ORDER=  (L) (CONS 'EQUAL (CDR L))) 
  270.  
  271. ;(MACRO SETRLINK  (L) (LIST 'RPLACD (LIST 'CADR (CADR L)) (CADDR L))) 
  272.  
  273. ;(MACRO SETLLINK  (L) (LIST 'RPLACA (LIST 'CADR (CADR L)) (CADDR L))) 
  274.  
  275. ;(MACRO SETBP  (L) (LIST 'RPLACA (LIST 'CDDR (CADR L)) (CADDR L))) 
  276.  
  277. ;(MACRO SETREC  (L) (LIST 'RPLACD (LIST 'CDDR (CADR L)) (CADDR L))) 
  278.  
  279. ;(DEFUN INSERT-IT (PP NEWREC) (SETREC PP (POISCO+ (REC PP) NEWREC))) 
  280.  
  281. ;(DEFUN AVLINSERT (K NEWREC HEAD)
  282. ; (PROG (QQ TT SS PP RR)
  283. ;     (SETQ TT HEAD)
  284. ;     (SETQ SS (SETQ PP (RLINK HEAD)))
  285. ; A2  (COND ((ORDER< K (KEY PP)) (GO A3))
  286. ;       ((ORDER< (KEY PP) K) (GO A4))
  287. ;       (T (INSERT-IT PP NEWREC) (RETURN HEAD)))
  288. ; A3  (SETQ QQ (LLINK PP))
  289. ;     (COND ((NULL QQ)
  290. ;        (SETLLINK PP (CONS K (CONS (NCONS NIL) (CONS 0 NEWREC))))
  291. ;        (GO A6))
  292. ;       ((ORDER= 0 (BP QQ)) NIL)
  293. ;       (T (SETQ TT PP SS QQ)))
  294. ;     (SETQ PP QQ)
  295. ;     (GO A2)
  296. ; A4  (SETQ QQ (RLINK PP))
  297. ;     (COND ((NULL QQ)
  298. ;        (SETRLINK PP (CONS K (CONS (NCONS NIL) (CONS 0 NEWREC))))
  299. ;        (GO A6))
  300. ;       ((ORDER= 0 (BP QQ)) NIL)
  301. ;       (T (SETQ TT PP SS QQ)))
  302. ;     (SETQ PP QQ)
  303. ;     (GO A2)
  304. ; A6  (COND ((ORDER< K (KEY SS)) (SETQ RR (SETQ PP (LLINK SS))))
  305. ;       (T (SETQ RR (SETQ PP (RLINK SS)))))
  306. ; A6LOOP
  307. ;     (COND ((ORDER< K (KEY PP)) (SETBP PP -1) (SETQ PP (LLINK PP)))
  308. ;       ((ORDER< (KEY PP) K) (SETBP PP 1) (SETQ PP (RLINK PP)))
  309. ;       ((ORDER= K (KEY PP)) (GO A7)))
  310. ;     (GO A6LOOP)
  311. ; A7  (COND ((ORDER< K (KEY SS)) (GO A7L)) (T (GO A7R)))
  312. ; A7L (COND ((ORDER= 0 (BP SS)) (SETBP SS -1) (SETLLINK HEAD (f1+ (LLINK HEAD))) (RETURN HEAD))
  313. ;       ((ORDER= (BP SS) 1) (SETBP SS 0) (RETURN HEAD)))
  314. ;     (COND ((ORDER= (BP RR) -1) NIL)
  315. ;       (T (GO A9L)))
  316. ;     (SETQ PP RR)
  317. ;     (SETLLINK SS (RLINK RR))
  318. ;     (SETRLINK RR SS)
  319. ;     (SETBP SS 0)
  320. ;     (SETBP RR 0)
  321. ;     (GO A10)
  322. ; A9L (SETQ PP (RLINK RR))
  323. ;     (SETRLINK RR (LLINK PP))
  324. ;     (SETLLINK PP RR)
  325. ;     (SETLLINK SS (RLINK PP))
  326. ;     (SETRLINK PP SS)
  327. ;     (COND ((ORDER= (BP PP) -1) (SETBP SS 1) (SETBP RR 0))
  328. ;       ((ORDER= (BP PP) 0) (SETBP SS 0) (SETBP RR 0))
  329. ;       ((ORDER= (BP PP) 1) (SETBP SS 0) (SETBP RR -1)))
  330. ;     (SETBP PP 0)
  331. ;     (GO A10)
  332. ; A7R (COND ((ORDER= 0 (BP SS)) (SETBP SS 1) (SETLLINK HEAD (f1+ (LLINK HEAD))) (RETURN HEAD))
  333. ;       ((ORDER= (BP SS) -1) (SETBP SS 0) (RETURN HEAD)))
  334. ;     (COND ((ORDER= (BP RR) 1) NIL)
  335. ;       (T (GO A9R)))
  336. ;     (SETQ PP RR)
  337. ;     (SETRLINK SS (LLINK RR))
  338. ;     (SETLLINK RR SS)
  339. ;     (SETBP SS 0)
  340. ;     (SETBP RR 0)
  341. ;     (GO A10)
  342. ; A9R (SETQ PP (LLINK RR))
  343. ;     (SETLLINK RR (RLINK PP))
  344. ;     (SETRLINK PP RR) 
  345. ;     (SETRLINK SS (LLINK PP))
  346. ;     (SETLLINK PP SS)
  347. ;     (COND ((ORDER= (BP PP) 1) (SETBP SS -1) (SETBP RR 0))
  348. ;       ((ORDER= (BP PP) 0) (SETBP SS 0) (SETBP RR 0))
  349. ;       ((ORDER= (BP PP) -1) (SETBP SS 0) (SETBP RR 1)))
  350. ;     (SETBP PP 0)
  351. ; A10 (COND ((EQ SS (RLINK TT)) (SETRLINK TT PP))
  352. ;       (T (SETLLINK TT PP)))
  353. ;     (RETURN HEAD))) 
  354.  
  355. ;(DEFUN AVLINIT (KEY REC)
  356. ;   (CONS 'TOP (CONS (CONS 0 (CONS KEY (CONS (NCONS NIL) (CONS 0 REC))))
  357. ;            (CONS 0 NIL)))) 
  358.  
  359. ;(DEFUN UNTREE (H)
  360. ;   (PROG (ANS)
  361. ;     (UNTREE1 (RLINK H))
  362. ;     (RETURN ANS))) 
  363.  
  364. ;(DEFUN UNTREE1 (H)
  365. ;   (COND ((NULL H) ANS)
  366. ;     ((NULL (RLINK H))
  367. ;      (SETQ ANS (TCONS3 (KEY H) (REC H) ANS))
  368. ;      (UNTREE1 (LLINK H)))
  369. ;     (T (SETQ ANS (TCONS3 (KEY H) (REC H) (UNTREE1 (RLINK H))))
  370. ;        (UNTREE1 (LLINK H))))) 
  371.  
  372. ;(DEFUN TCONS3 (R S TT)
  373. ;   (COND ((POISPZERO S) TT)
  374. ;     (T (CONS R (CONS S TT))))) 
  375.  
  376. ;(DEFUN POISMERGES (A AE L)
  377. ;   (COND ((EQUAL POISHIFT AE) L)
  378. ;     ((POISNEGPRED AE) (POISMERGE (POISCO* POISCOM1 A)
  379. ;                      (POISCHANGESIGN AE) L))
  380. ;     (T (POISMERGE A AE L)))) 
  381.  
  382. ;(DEFUN POISMERGEC (A AE L)
  383. ;   (COND ((POISNEGPRED AE) (POISMERGE A (POISCHANGESIGN AE) L))
  384. ;     (T (POISMERGE A AE L)))) 
  385.  
  386. ;(DEFUN POISMERGE (A AE L)
  387. ;       (COND ((POISPZERO A) NIL)
  388. ;         (T (MERGE11 A AE L)))) 
  389.  
  390. ;(DEFUN POISMERGE2 (R S)
  391. ;   (COND ((NULL R) S)
  392. ;     ((NULL S) R)
  393. ;     (T (PROG (M N TT)
  394. ;          (SETQ M (SETQ N (CONS 0 R)))
  395. ;     A    (COND ((NULL R) (RPLACD M S) (RETURN (CDR N)))
  396. ;            ((NULL S) (RETURN (CDR N)))
  397. ;            ((EQUAL (CAR R) (CAR S))
  398. ;               (SETQ TT (POISCO+ (CADR R) (CADR S)))
  399. ;               (COND ((POISPZERO TT)
  400. ;                  (RPLACD M (CDDR R))
  401. ;                  (SETQ R (CDDR R) S (CDDR S)))
  402. ;                 (T (RPLACA (CDR R) TT)
  403. ;                (SETQ S (CDDR S) R (CDDR R) M (CDDR M)))))
  404. ;            ((GREATERP (CAR R) (CAR S))
  405. ;               (RPLACD M S)
  406. ;               (SETQ S (CDDR S))
  407. ;               (RPLACD (CDDR M) R)
  408. ;               (SETQ M (CDDR M)))
  409. ;            (T (SETQ R (CDDR R))
  410. ;               (SETQ M (CDDR M))))
  411. ;          (GO A))))) 
  412.  
  413. ;(DEFUN MERGE11 (A AE L)
  414. ;       (POISMERGE2 (LIST AE A) L)) 
  415.  
  416. ;(DEFUN POISMERGESX (A AE L)
  417. ;   (COND ((EQUAL POISHIFT AE) L)
  418. ;     ((POISNEGPRED AE)
  419. ;      (AVLINSERT (POISCHANGESIGN AE)
  420. ;             (POISCO* POISCOM1 A)
  421. ;             L))
  422. ;     (T (AVLINSERT AE A L)))) 
  423.  
  424. ;(DEFUN POISMERGECX (A AE L)
  425. ;   (COND ((POISNEGPRED AE)
  426. ;      (AVLINSERT (POISCHANGESIGN AE) A L))
  427. ;     (T (AVLINSERT AE A L)))) 
  428.  
  429. (DECLARE-TOP (SPECIAL TRIM POISCOM1 POISHIFT)) 
  430. ;(DEFUN POISCTIMES1 (C H)
  431. ;   (COND ((NULL H) NIL)
  432. ;     ((AND TRIM (TRIMF (CAR H))) (POISCTIMES1 C (CDDR H)))
  433. ;     (T (TCONS (CAR H)
  434. ;           (CONS (POISCO* C (CADR H))
  435. ;             (POISCTIMES1 C (CDDR H))))))) 
  436.  
  437. ;(DEFUN TRIMF (M)
  438. ;   (MEVAL (LIST '($POISTRIM) (POISXCOEF M '$U) (POISXCOEF M '$V)
  439. ;        (POISXCOEF M '$W) (POISXCOEF M '$X) (POISXCOEF M '$Y) (POISXCOEF M '$Z)))) 
  440.  
  441. ;(DEFMFUN $POISTIMES (A B) 
  442. ;       (PROG (SLC CLC TEMP AE AA ZERO TRIM T1 T2 F1 F2) 
  443. ;             (SETQ A (INTOPOIS A) B (INTOPOIS B))
  444. ;             (COND ((OR (GETL '$POISTRIM '(EXPR SUBR)) (MGET '$POISTRIM 'MEXPR))
  445. ;                    (SETQ TRIM T)))
  446. ;             (COND ((NONPERIOD A) (RETURN ($POISCTIMES (CADR (CADDR A)) B)))
  447. ;                   ((NONPERIOD B) (RETURN ($POISCTIMES (CADR (CADDR B)) A))))
  448. ;             (SETQ SLC (AVLINIT POISHIFT (SETQ ZERO (INTOPOISCO 0.))))
  449. ;         (SETQ CLC (AVLINIT POISHIFT ZERO))
  450. ;             ;; PROCEED THROUGH ALL THE SINES IN ARGUMENT A
  451. ;             (DO SLA
  452. ;                 (CADR A)
  453. ;                 (CDDR SLA)
  454. ;                 (NULL SLA)
  455. ;                 (SETQ AA (HALVE (CADR SLA)) AE (CAR SLA))
  456. ;                 ;; SINE(U)*SINE(V) ==> (-COSINE(U+V) + COSINE(U-V))/2
  457. ;                 (DO SLB
  458. ;                     (CADR B)
  459. ;                     (CDDR SLB)
  460. ;                     (NULL SLB)
  461. ;                     (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR SLB)))
  462. ;               T2 (PLUS AE (MINUS POISHIFT) (CAR SLB)))
  463. ;             (COND (TRIM (SETQ F1 (TRIMF T1) F2 (TRIMF T2)))
  464. ;               (T (SETQ F1 NIL F2 NIL)))
  465. ;                            (SETQ TEMP (POISCO* AA (CADR SLB)))
  466. ;                              (COND ((POISPZERO TEMP) NIL)
  467. ;                                    (T (OR F1 (POISMERGECX TEMP T1 CLC))
  468. ;                                       (OR F2 (POISMERGECX (POISCO* POISCOM1 TEMP) T2 CLC)))))
  469. ;                 ;; SINE*COSINE ==> SINE + SINE
  470. ;                 (DO CLB
  471. ;                     (CADDR B)
  472. ;                     (CDDR CLB)
  473. ;                     (NULL CLB)
  474. ;                     (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR CLB)))
  475. ;               T2 (PLUS AE (MINUS POISHIFT) (CAR CLB)))
  476. ;             (COND (TRIM (SETQ F1 (TRIMF T1) F2 (TRIMF T2)))
  477. ;               (T (SETQ F1 NIL F2 NIL)))
  478. ;                      (SETQ TEMP (POISCO* AA (CADR CLB)))
  479. ;                        (COND ((POISPZERO TEMP) NIL)
  480. ;                              (T (OR F1 (POISMERGESX TEMP T1 SLC))
  481. ;                 (OR F2 (POISMERGESX TEMP T2 SLC))))))
  482. ;             ;; PROCEED THROUGH ALL THE COSINES IN ARGUMENT A
  483. ;             (DO CLA
  484. ;                 (CADDR A)
  485. ;                 (CDDR CLA)
  486. ;                 (NULL CLA)
  487. ;                 (SETQ AA (HALVE (CADR CLA)) AE (CAR CLA))
  488. ;                 ;; COSINE*SINE ==> SINE - SINE
  489. ;                 (DO SLB
  490. ;                     (CADR B)
  491. ;                     (CDDR SLB)
  492. ;                     (NULL SLB)
  493. ;                     (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR SLB))))
  494. ;             (SETQ T2 (PLUS AE (MINUS POISHIFT) (CAR SLB)))
  495. ;             (COND (TRIM (SETQ F1 (TRIMF T1) F2 (TRIMF T2)))
  496. ;               (T (SETQ F1 NIL F2 NIL)))
  497. ;             (SETQ TEMP (POISCO* AA (CADR SLB)))
  498. ;             (COND ((POISPZERO TEMP) NIL)
  499. ;               (T (OR F1 (POISMERGESX (POISCO* POISCOM1 TEMP) T1 SLC))
  500. ;                  (OR F2 (POISMERGESX TEMP T2 SLC)))))
  501. ;         ;; COSINE*COSINE ==> COSINE + COSINE
  502. ;                 (DO CLB
  503. ;                     (CADDR B)
  504. ;                     (CDDR CLB)
  505. ;                     (NULL CLB)
  506. ;                     (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR CLB))))
  507. ;             (SETQ T2 (PLUS AE (MINUS POISHIFT) (CAR CLB)))
  508. ;             (COND (TRIM (SETQ F1 (TRIMF T1) F2 (TRIMF T2)))
  509. ;               (T (SETQ F1 NIL F2 NIL)))
  510. ;             (SETQ TEMP (POISCO* AA (CADR CLB)))
  511. ;             (COND ((POISPZERO TEMP) NIL)
  512. ;               (T (OR F1 (POISMERGECX TEMP T1 CLC))
  513. ;                  (OR F2 (POISMERGECX TEMP T2 CLC))))))
  514. ;             (RETURN (LIST '(MPOIS SIMP) (UNTREE SLC) (UNTREE CLC)))))
  515.  
  516. ;(DEFMFUN $POISEXPT (P N) 
  517. ;       (PROG (U H) 
  518. ;         (COND ((ODDP N) (SETQ U P)) (T (SETQ U (SETQ H (INTOPOIS 1.)))))
  519. ;    A    (SETQ N (LSH N -1.))
  520. ;         (COND ((ZEROP N) (RETURN U)))
  521. ;         (setq p ($POISTIMES P P))
  522. ;         (COND ((ODDP N) (SETQ U (COND ((EQUAL U H) P) (T ($POISTIMES U P))))))
  523. ;         (GO A))) 
  524.  
  525. ;(DEFMFUN $POISSQUARE (A) ($POISEXPT A 2))
  526.  
  527. ;(DEFMFUN $POISINT (P M)
  528. ;  (DECLARE (SPECIAL M)) 
  529. ;   (PROG (B*)
  530. ;     (SETQ P (INTOPOIS P))
  531. ;     (COND ((MEMQ M '($U $V $W $X $Y $Z))
  532. ;        (RETURN (LIST (CAR P) (COSINT* (CADDR P) M) (SININT* (CADR P) M))))
  533. ;       (T (RETURN (LIST (CAR P) (POISINT4 (CADR P)) (POISINT4 (CADDR P)))))))) 
  534.  
  535. ;(DEFUN POISINT4 (Y)
  536. ;  (DECLARE (SPECIAL M)) 
  537. ;   (COND ((NULL Y) NIL)
  538. ;     (T (TCONS3 (CAR Y)
  539. ;            (POISCOINTEG (CADR Y) M)
  540. ;            (POISINT4 (CDDR Y)))))) 
  541.  
  542. ;(DEFUN COSINT* (H M)
  543. ;   (COND ((NULL H) NIL)
  544. ;     ((EQUAL 0 (SETQ B* (POISXCOEF (CAR H) M)))
  545. ;      (COSINT* (CDDR H) M))
  546. ;     (T (TCONS (CAR H)
  547. ;           (CONS (POISCO* (INTOPOISCO (LIST '(MEXPT) B* -1)) (CADR H))
  548. ;             (COSINT* (CDDR H) M)))))) 
  549.  
  550. ;(DEFUN SININT* (H M)
  551. ;   (COND ((NULL H) NIL)
  552. ;     ((EQUAL 0 (SETQ B* (POISXCOEF (CAR H) M)))
  553. ;      (SININT* (CDDR H) M))
  554. ;     (T (TCONS (CAR H)
  555. ;           (CONS (POISCO* (INTOPOISCO (LIST '(MEXPT) (MINUS (POISXCOEF (CAR H) M)) -1))
  556. ;                  (CADR H))
  557. ;             (SININT* (CDDR H) M)))))) 
  558.  
  559. ;(DEFUN POISSUBSTA (A B* C)
  560. ;   (PROG (SS CC)
  561. ;      (SETQ H* (DIFFERENCE (POISENCODE (LIST '(MPLUS) A (LIST '(MTIMES) -1 B*))) POISHIFT))
  562. ;      (POISSUBST1S (CADR C))
  563. ;      (POISSUBST1C (CADDR C))
  564. ;      (RETURN (LIST (CAR C) SS CC)))) 
  565.  
  566. ;(DEFUN POISSUBST1S (C)
  567. ;   (COND ((NULL C) NIL)
  568. ;     (T (SETQ SS (POISMERGES (CADR C) (ARGSUBST (CAR C)) SS))
  569. ;        (POISSUBST1S (CDDR C))))) 
  570.  
  571. ;(DEFUN POISSUBST1C (C)
  572. ;   (COND ((NULL C) NIL)
  573. ;     (T (SETQ CC (POISMERGEC (CADR C) (ARGSUBST (CAR C)) CC))
  574. ;        (POISSUBST1C (CDDR C))))) 
  575.  
  576. ;(DEFUN ARGSUBST (C)
  577. ;       (PLUS C (TIMES H* (POISXCOEF C B*)))) 
  578.  
  579. ;(DEFMFUN $POISSUBST N
  580. ;   (COND ((NOT (OR (EQUAL N 3) (EQUAL N 5)))
  581. ;      (merror "WRONG NUMBER OF ARGS TO POISSUBST"))
  582. ;     ((EQUAL N 5)
  583. ;      (FANCYPOISSUBST (ARG 1) (ARG 2) (INTOPOIS (ARG 3)) (INTOPOIS (ARG 4)) (ARG 5)))
  584. ;     (T ((LAMBDA (A* B* C)
  585. ;         (COND ((MEMQ B* '($U $V $W $X $Y $Z)) (POISSUBSTA A* B* C))
  586. ;               (T (LIST (CAR C) (POISSUBSTCO1 (CADR C)) (POISSUBSTCO1 (CADDR C))))))
  587. ;           (ARG 1) (ARG 2) (INTOPOIS (ARG 3)))))) 
  588.  
  589. ;(DEFUN POISSUBSTCO1 (C)
  590. ;   (COND ((NULL C) NIL)
  591. ;     (T (TCONS (CAR C)
  592. ;           (CONS (POISSUBSTCO A* B* (CADR C))
  593. ;             (POISSUBSTCO1 (CDDR C))))))) 
  594.  
  595. (DECLARE-TOP (SPECIAL DC DS *ANS)) 
  596. ;(DEFUN FANCYPOISSUBST (A B* C D N)
  597. ;   (PROG (H* DC DS *ANS)
  598. ;     (SETQ *ANS (LIST '(MPOIS SIMP) NIL NIL)
  599. ;       D (INTOPOIS D)
  600. ;       DC (INTOPOIS 1)
  601. ;       DS (INTOPOIS 0))
  602. ;     (COND ((EQUAL N 0) (RETURN ($POISSUBST A B* C))))
  603. ;     (FANCYPOIS1S D 1 1 N)
  604. ;     (SETQ H* (DIFFERENCE (POISENCODE (LIST '(MPLUS) A (LIST '(MTIMES) -1 B*))) POISHIFT))
  605. ;     (FANCYPAS (CADR C))
  606. ;     (FANCYPAC (CADDR C))
  607. ;     (RETURN *ANS))) 
  608.  
  609. ;(DEFUN FANCYPOIS1S (D DP N LIM)
  610. ;   (COND ((GREATERP N LIM) NIL)
  611. ;     (T (SETQ DS ($POISPLUS DS
  612. ;                ($POISCTIMES (LIST '(RAT)
  613. ;                           (EXPT -1 (QUOTIENT (SUB1 N) 2))
  614. ;                           (FACTORIAL N))
  615. ;                         (SETQ DP ($POISTIMES DP D)))))
  616. ;        (FANCYPOIS1C D DP (f1+ N) LIM))))
  617.  
  618. ;(DEFUN FANCYPOIS1C (D DP N LIM)
  619. ;   (COND ((GREATERP N LIM) NIL)
  620. ;     (T (SETQ DC ($POISPLUS DC
  621. ;                ($POISCTIMES (LIST '(RAT)
  622. ;                           (EXPT -1 (QUOTIENT N 2))
  623. ;                           (FACTORIAL N))
  624. ;                         (SETQ DP ($POISTIMES DP D)))))
  625. ;        (FANCYPOIS1S D DP (f1+ N) LIM))))
  626.  
  627. (DECLARE-TOP (SPECIAL *ARGC *COEF)) 
  628. ;(DEFUN FANCYPAC (C)
  629. ;   (PROG ()
  630. ;     (COND ((NULL C) (RETURN NIL)))
  631. ;     (SETQ *COEF (POISXCOEF (CAR C) B*))
  632. ;     (COND ((EQUAL *COEF 0)
  633. ;        (SETQ *ANS ($POISPLUS *ANS (LIST '(MPOIS SIMP) NIL (LIST (CAR C) (CADR C)))))
  634. ;        (GO END)))
  635. ;     (COND ((POISPZERO (SETQ *COEF (POISCO* (CADR C) (INTOPOISCO *COEF)))) (GO END)))
  636. ;     (SETQ *ARGC (ARGSUBST (CAR C)))
  637. ;     (SETQ *ANS ($POISPLUS *ANS
  638. ;               ($POISPLUS ($POISTIMES (LIST '(MPOIS SIMP)
  639. ;                            NIL
  640. ;                            (POISMERGEC *COEF *ARGC NIL))
  641. ;                          DC)
  642. ;                      ($POISTIMES (LIST '(MPOIS SIMP)
  643. ;                            (POISMERGES (POISCO* POISCOM1 *COEF)
  644. ;                                    *ARGC
  645. ;                                    NIL)
  646. ;                            NIL)
  647. ;                          DS))))
  648. ; END (FANCYPAC (CDDR C))))
  649.  
  650. ;(DEFUN FANCYPAS (C)
  651. ;   (PROG ()
  652. ;     (COND ((NULL C) (RETURN NIL)))
  653. ;     (SETQ *COEF (POISXCOEF (CAR C) B*))
  654. ;     (COND ((EQUAL *COEF 0)
  655. ;        (SETQ *ANS ($POISPLUS *ANS (LIST '(MPOIS SIMP) (LIST (CAR C) (CADR C)) NIL)))
  656. ;        (GO END)))
  657. ;     (COND ((POISPZERO (SETQ *COEF (POISCO* (CADR C) (INTOPOISCO *COEF))))
  658. ;        (GO END)))
  659. ;     (SETQ *ARGC (ARGSUBST (CAR C)))
  660. ;     (SETQ *ANS ($POISPLUS *ANS
  661. ;               ($POISPLUS ($POISTIMES (LIST '(MPOIS SIMP)
  662. ;                            NIL
  663. ;                            (POISMERGEC *COEF *ARGC NIL))
  664. ;                          DS)
  665. ;                      ($POISTIMES (LIST '(MPOIS SIMP)
  666. ;                            (POISMERGES *COEF *ARGC NIL)
  667. ;                            NIL)
  668. ;                          DC))))
  669. ; END (FANCYPAS (CDDR C)))) 
  670.  
  671. ;; On the VAX, this should be smaller than on the 10.
  672.  
  673. (POISLIM1 NIL #-Franz 5 #+Franz 4)
  674.  
  675. ;(DEFUN POISCDECODE (X) X) 
  676.  
  677. ;(DEFUN INTOPOISCO (X) (SIMPLIFYA X NIL)) 
  678.  
  679. ;(DEFUN POISCO+ (R S) (SIMPLIFYA (LIST '(MPLUS) R S) NIL)) 
  680.  
  681. ;(DEFUN POISCO* (R S) (SIMPLIFYA (LIST '(MTIMES) R S) NIL)) 
  682.  
  683. ;(DEFUN HALVE (R) (SIMPLIFYA (LIST '(MTIMES) '((RAT) 1 2) R) NIL)) 
  684.  
  685. ;(DEFUN POISSUBSTCO (A B C) (MAXIMA-SUBSTITUTE A B C)) 
  686.  
  687. ;(DEFUN POISCODIF (H VAR) ($DIFF H VAR)) 
  688.  
  689. ;(DEFUN POISCOINTEG (H VAR) (INTOPOISCO ($INTEGRATE (POISCDECODE H) VAR))) 
  690.  
  691. ;(DEFUN POISPZERO (X) (ZEROP1 X)) 
  692.  
  693. (SETQ POISCO1 1 POISCOM1 -1) 
  694.  
  695. ;(COMMENT
  696.  
  697. ; (DECLARE-TOP (SPECIAL SLCX CLCX LASTPTR TRIM POISCOM1 POISHIFT CLC SLC CLCPTR SLCPTR))
  698.  
  699. ; (DEFUN POISMERGE2K (S R)
  700. ;   (COND ((NULL R) (SETQ LASTPTR S))
  701. ;     ((NULL S) (SETQ LASTPTR R))
  702. ;     (T (PROG (M N TT)
  703. ;          (SETQ M (SETQ N (CONS 0 R)))
  704. ;        A (COND ((NULL R) (RPLACD M S) (SETQ LASTPTR S) (RETURN (CDR N)))
  705. ;            ((NULL S) (SETQ LASTPTR R) (RETURN (CDR N)))
  706. ;            ((EQUAL (CAR R) (CAR S))
  707. ;             (SETQ TT (POISCO+ (CADR R) (CADR S)))
  708. ;             (COND ((POISPZERO TT) (RPLACD M (CDDR R))
  709. ;                           (SETQ R (CDDR R) S (CDDR S)))
  710. ;                   (T (RPLACA (CDR R) TT)
  711. ;                  (SETQ S (CDDR S) R (CDDR R) M (CDDR M)))))
  712. ;            ((GREATERP (CAR R) (CAR S))
  713. ;             (RPLACD M S) (SETQ S (CDDR S))
  714. ;             (RPLACD (CDDR M) R) (SETQ M (CDDR M)))
  715. ;            (T (SETQ R (CDDR R)) (SETQ M (CDDR M))))
  716. ;          (GO A)))))
  717.  
  718. ; (DEFUN POISMERGESQ (A AE L)
  719. ;    (SETQ SLCX
  720. ;          (COND ((EQUAL POISHIFT AE) L)
  721. ;            ((POISNEGPRED AE) (POISMERGE (POISCO* POISCOM1 A) (POISCHANGESIGN AE) L))
  722. ;            (T (POISMERGE A AE L)))))
  723.  
  724. ; (DEFUN POISMERGECQ (A AE L)
  725. ;     (SETQ CLCX (COND ((POISNEGPRED AE) (POISMERGE A (POISCHANGESIGN AE) L))
  726. ;              (T (POISMERGE A AE L)))))
  727.  
  728. ; (DEFUN POISMERGESY (A AE L)
  729. ;     (SETQ SLC
  730. ;       (COND ((EQUAL POISHIFT AE) L)
  731. ;         ((POISNEGPRED AE) (POISMERGESY1 (POISCO* POISCOM1 A) (POISCHANGESIGN AE) L))
  732. ;         (T (POISMERGESY1 A AE L)))))
  733.   
  734. ; (DEFUN POISMERGECY (A AE L)
  735. ;     (SETQ CLC (COND ((POISNEGPRED AE) (POISMERGECY1 A (POISCHANGESIGN AE) L))
  736. ;             (T (POISMERGECY1 A AE L)))))
  737.   
  738. ; (DEFUN POISMERGECY1 (A AE L)
  739. ;     (COND ((POISPZERO A) NIL)
  740. ;       ((OR (NULL CLCPTR) (LESSP AE (CAR CLCPTR)))
  741. ;          (SETQ CLC (POISMERGE2K (LIST AE A) L)) (SETQ CLCPTR LASTPTR))
  742. ;       (T (POISMERGE2K (LIST AE A) CLCPTR) (SETQ CLCPTR LASTPTR)))
  743. ;     CLC)
  744.   
  745. ; (DEFUN POISMERGESY1 (A AE L)
  746. ;     (COND ((POISPZERO A) NIL)
  747. ;       ((OR (NULL SLCPTR) (LESSP AE (CAR SLCPTR)))
  748. ;          (SETQ SLC (POISMERGE2K (LIST AE A) L)) (SETQ SLCPTR LASTPTR))
  749. ;       (T (POISMERGE2K (LIST AE A) SLCPTR) (SETQ SLCPTR LASTPTR)))
  750. ;     SLC)
  751.   
  752. ; (DEFMFUN $POISTIMESL (A B)
  753. ;    (PROG (SLC SLCPTR CLC CLCPTR TEMP AE AA TRIM T1 T2 F1 F2 LASTPTR SLCX CLCX)
  754. ;    (SETQ A (INTOPOIS A) B (INTOPOIS B))
  755. ;    (COND ((OR (GETL '$POISTRIM '(EXPR SUBR)) (MGET '$POISTRIM 'MEXPR)) (SETQ TRIM T)))
  756. ;    (COND ((NONPERIOD A) (RETURN ($POISCTIMES (CADR (CADDR A)) B)))
  757. ;          ((NONPERIOD B) (RETURN ($POISCTIMES (CADR (CADDR B)) A))))
  758. ;    (SETQ SLCPTR SLC CLCPTR CLC CLCX NIL SLCX NIL)
  759. ;    (DO SLA (CADR A) (CDDR SLA) (NULL SLA)
  760. ;      (SETQ AA (HALVE (CADR SLA)) AE (CAR SLA))
  761. ;      (DO SLB (CADR B) (CDDR SLB) (NULL SLB)
  762. ;        (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR SLB)))
  763. ;          T2 (PLUS AE (MINUS POISHIFT) (CAR SLB)))
  764. ;        (COND ((AND TRIM (SETQ F1 (TRIMF T1)) (SETQ F2 (TRIMF T2))) (SETQ F1 NIL F2 NIL))
  765. ;          (T (SETQ TEMP (POISCO* AA (CADR SLB)))
  766. ;             (COND ((POISPZERO TEMP) NIL)
  767. ;               (T (OR F1 (POISMERGECQ TEMP T1 CLCX))
  768. ;                  (OR F2 (POISMERGECY (POISCO* POISCOM1 TEMP) T2 CLC)))))))
  769. ;      (DO CLB (CADDR B) (CDDR CLB) (NULL CLB)
  770. ;        (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR CLB)))
  771. ;          T2 (PLUS AE (MINUS POISHIFT) (CAR CLB)))
  772. ;        (COND ((AND TRIM (SETQ F1 (TRIMF T1)) (SETQ F2 (TRIMF T2))) (SETQ F1 NIL F2 NIL))
  773. ;          (T (SETQ TEMP (POISCO* AA (CADR CLB)))
  774. ;             (COND ((POISPZERO TEMP) NIL) (T (OR F1 (POISMERGESQ TEMP T1 SLCX))
  775. ;                             (OR F2 (POISMERGESY TEMP T2 SLC))))))))
  776. ;    (SETQ CLC (POISMERGE2 CLC CLCX) SLC (POISMERGE2 SLC SLCX))
  777. ;    (SETQ SLCPTR SLC CLCPTR CLC SLCX NIL CLCX NIL)
  778. ;    (DO CLA (CADDR A) (CDDR CLA) (NULL CLA)
  779. ;      (SETQ AA (HALVE (CADR CLA)) AE (CAR CLA))
  780. ;      (DO SLB (CADR B) (CDDR SLB) (NULL SLB)
  781. ;        (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR SLB)))
  782. ;          T2 (PLUS AE (MINUS POISHIFT) (CAR SLB)))
  783. ;        (COND ((AND TRIM (SETQ F1 (TRIMF T1)) (SETQ F2 (TRIMF T2))) (SETQ F1 NIL F2 NIL))
  784. ;          (T (SETQ TEMP (POISCO* AA (CADR SLB)))
  785. ;             (COND ((POISPZERO TEMP) NIL)
  786. ;               (T (OR F1 (POISMERGESQ (POISCO* POISCOM1 TEMP) T1 SLCX))
  787. ;                  (OR F2 (POISMERGESY TEMP T2 SLC)))))))
  788. ;      (DO CLB (CADDR B) (CDDR CLB) (NULL CLB)
  789. ;        (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR CLB)))
  790. ;          T2 (PLUS AE (MINUS POISHIFT) (CAR CLB)))
  791. ;        (COND ((AND TRIM (SETQ F1 (TRIMF T1)) (SETQ F2 (TRIMF T2))) (SETQ F1 NIL F2 NIL))
  792. ;          (T (SETQ TEMP (POISCO* AA (CADR CLB)))
  793. ;             (COND ((POISPZERO TEMP) NIL) (T (OR F1 (POISMERGECQ TEMP T1 CLCX))
  794. ;                             (OR F2 (POISMERGECY TEMP T2 CLC))))))))
  795. ;    (SETQ CLC (POISMERGE2 CLC CLCX) SLC (POISMERGE2 SLC SLCX))
  796. ;    (RETURN (LIST '(MPOIS SIMP) SLC CLC))))
  797.  
  798. ;) ;End of commented out code
  799.  
  800.